perm filename WLDMOD.SAI[AL,HE]2 blob
sn#314211 filedate 1977-11-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002
C00004 00003 SIMPLE PROCEDURE STITINI
C00005 00004 ! fluent_rec,fluent_fact
C00006 00005 ! csplit, stmchk, is_undef_sym_item
C00007 00006 ! world assignment: xxxwld, wldasg (lpbasg, parasg)
C00013 00007 ! check_guards
C00014 00008 ! fluent_check,mergein
C00016 00009 ! cpattl
C00018 00010 ! asrtit & denyit
C00021 00011 ! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo
C00023 00012 ! younger,afxdget
C00026 00013 ! controllable, deproach
C00031 00014 ! dexprset, domove, dooperate, dostop
C00048 00015 ! do_affix, do_affix_stmnt, do_unfix
C00053 00016 ! blockdo & sttblk, blkopdo
C00056 00017 ! Cobdo
C00058 00018 ! loopbdo
C00059 00019 ! statement interpreter: stinterp (owdo, iwcopy)
C00068 00020 ifcr false thenc ! proc_form interpreter: apfrm, apfrm2
C00070 00021 ! test program
C00071 ENDMK
C⊗;
IFCR ¬DECLARATION(EXTENDED_COMPILATION) THENC
ENTRY;
BEGIN "WLDMOD"
IFCR ¬DECLARATION(CREFFING) THENC DEFINE CREFFING = FALSE;ENDC
IFCR ¬ CREFFING THENC
REQUIRE "ALREQ.HDR[AL,HE]" SOURCE_FILE;
ENDC
REDEFINE $$PRGID "[]" = ["WLDMOD"];
ENDC
REQUIRE 300 SYSTEM_PDL;
INTEGER STITRC;
RPTR(SPECVAL) VNEWTRANS;
PROCEDURE VNEWINI;
BEGIN
VNEWTRANS←NEW_RECORD(SPECVAL);
SPECVAL:TYPE[VNEWTRANS]←TRANS_DTYPE;
END;
REQUIRE VNEWINI INITIALIZATION;
RPTR(BLOCK) CURBLK; ! id of current block in stinterp;
SIMPLE PROCEDURE STITINI;
BEGIN
OUTSTR("
SET TRACE OPTIONS FOR STINTERP:
'1 -- print ""statement"" type
'2 -- print ""statement"" record
type in one fhq octal number:");
STITRC←CVO(INCHWL);
END;
! fluent_rec,fluent_fact;
RPTR(FLUENT) FLUENT_REC; ! set by fluent_fact;
BOOLEAN PROCEDURE FLUENT_FACT(RPTR(FACT) F);
BEGIN
RANY PTN;
PTN←FACT:PATT[F];
IF RECLEN(PTN)≠2 THEN RETURN(FALSE);
START_CODE "FLFSTC"
LABEL XXX,XXX0;
SKIPE 1,PTN;
SKIPN 1,1(1);
JRST XXX;
TLC 1,REC_CODE;
TLNE 1,(PROCB+ARY2B+ITEMB+'3740);
JRST XXX0; ! false if first isn't ref(record);
HRRZ 1,(1); ! point at record;
MOVEM 1,FLUENT_REC;
HRRZ 1,(1); ! point at record type;
CAIN 1,FLUENT;
XXX0: TDZA 1,1;
MOVEI 1,1;
XXX: END;
END;
! csplit, stmchk, is_undef_sym_item;
SIMPLE ITEMVAR PROCEDURE CSPLIT(ITEMVAR IW;BOOLEAN NEWFG(TRUE));
RETURN(IF NEWFG THEN NEWWLD ELSE IW);
! be sure S is a statement;
RPTR(STMNT) PROCEDURE STMCHK(RANY S);
RETURN(CHKREC(S,LOC(STMNT)));
! world assignment: xxxwld, wldasg (lpbasg, parasg);
SIMPLE ITEMVAR PROCEDURE XXXWLD(ITEMVAR INW;BOOLEAN CLANY(FALSE));
BEGIN
! Makes a copy of the input world and returns it. If CLANY
is TRUE, then the "clear" field of the new world is set to
ANY. Otherwise, it is copied from the old world.;
ITEMVAR OUW;
OUW←NEWWLD;
CLEAR[WLDINX(OUW)]←IF CLANY THEN ANY ELSE CLEAR[WLDINX(INW)];
COPY_ALERTS(INW,OUW);
RETURN(OUW);
END;
INTERNAL RECURSIVE PROCEDURE WLDASG(RPTR(STMNT) S;
ITEMVAR IW;REFERENCE ITEMVAR OW;REFERENCE BOOLEAN NFLAG);
BEGIN
! Assigns worlds to statements associated with the statement
S. If NFLAG is true, then something or other special
happens. (This flag is used to avoid assigning separate
worlds to successive assignment statements).
No longer makes the variable list for blocks.
;
LABEL XIT;
RANY SS;
INTEGER ST;
RCELL C;
BOOLEAN NF;
RECPROC LPBASG(RPTR(STMNT) SS);
BEGIN
! Handles the special case of a loop body;
ITEMVAR IWW,WW;
IF SS = RNULL THEN RETURN;
NF←TRUE;
IWW←XXXWLD(IW,TRUE);
WW←PREP_ALERT(IWW);
CLEAR[WLDINX(IWW)]←WW;
WLDASG(SS,IWW,OW,NF);
END;
RECPROC PARASG(RCELL C);
BEGIN
! CDRs down a list of statements that are meant to be
parallel in execution, doing the world assignments.
Assigns a world to the end as well;
WHILE C≠NULL_RECORD DO
BEGIN
NF←TRUE;
WLDASG(STMCHK(CELL:CAR[C]),XXXWLD(IW,TRUE),OW,NF);
C←CELL:CDR[C];
END;
OW←XXXWLD(IW);
END;
SS←STMNT:SEMANTICS[S];
ST←RECTYPE(SS);
STMNT:IW[S]←IW;
IF ST=0 ∨ ST=LOC(COMMNT) ∨ ST=LOC(PAUSE) ∨ ST=LOC(ABORT) ∨
ST=LOC(PRNT) ∨ ST=LOC(CMABLE) ∨ ST=LOC(CENTER) THEN
BEGIN
OW←STMNT:OW[S]←IW;
RETURN;
END;
IF ST=LOC(ASSERT)∨ST=LOC(DENY) THEN
BEGIN
IF ASSERT:WLD[SS]≠ANY THEN
BEGIN
OW←IW;
END
ELSE
BEGIN
OW←IF NFLAG THEN XXXWLD(IW) ELSE IW;
ASSERT:WLD[SS]←OW;
NFLAG←FALSE;
END;
STMNT:OW[S]←OW;
RETURN;
END
ELSE IF ST=LOC(ASSIGNMENT)∨ST=LOC(GASSIGN) THEN
BEGIN
OW←STMNT:OW[S]←IF NFLAG THEN XXXWLD(IW) ELSE IW;
NFLAG←FALSE;
RETURN;
END
ELSE
NFLAG←TRUE;
NF←TRUE;
IF ST=LOC(BLOCK) THEN
BEGIN "blkasg"
RPTR(BLOCK) B;
B←SS;
C←BLOCK:CODE[B];
OW←IW;
WHILE C≠NULL_RECORD DO
BEGIN
SS←CELL:CAR[C];
ST←RECTYPE(SS);
IF ST=LOC(STMNT) THEN ! Ignores PVL,VARIABLE,DBD,NW,NOTE;
BEGIN "sasa"
WLDASG(SS,OW,OW,NF);
END;
C←CELL:CDR[C];
END;
! **** perhaps will want to give blocks their own variables ****;
END
ELSE IF ST=LOC(COBLOCK) THEN
BEGIN
PARASG(COBLOCK:CODE[SS]);
END
ELSE IF ST=LOC(FORR) THEN
LPBASG(FORR:BODY[SS])
ELSE IF ST=LOC(WHIL) THEN
LPBASG(WHIL:BODY[SS])
ELSE IF ST=LOC(IFF) THEN
BEGIN
NF←TRUE;
WLDASG(IFF:THN[SS],XXXWLD(IW,TRUE),OW,NF);
NF←TRUE;
WLDASG(IFF:ELS[SS],XXXWLD(IW,TRUE),OW,NF);
OW←XXXWLD(IW);
END
ELSE IF ST=LOC(NW) THEN
BEGIN
NFLAG←FALSE;
OW←NW:WLD[SS];
IF OW=ANY THEN
OW←XXXWLD(IW)
ELSE
BEGIN
CLEAR[WLDINX(OW,-1)]←CLEAR[WLDINX(IW)];
COPY_ALERTS(IW,OW);
END;
END
ELSE IF ST=LOC(PROG) THEN
BEGIN
! **** Not sure what to do here with NFLAG & NF ****;
WLDASG(PROG:CODE[SS],IW,OW,NF); ! Was XXXWLD(IW,TRUE);
END
ELSE IF ST=LOC(MOVE$) THEN
BEGIN ! Coded by ARG;
RCELL C;
RANY X;
C←MOVE$:CLAUSES[SS];
WHILE C≠NULL_RECORD DO
BEGIN
X←LLOP(C);
IF RECTYPE(X)=LOC(CMON) THEN
WLDASG(CMON:CONCLUSION[X],XXXWLD(IW,TRUE),OW,NF);
END;
OW←XXXWLD(IW);
END
ELSE IF ST=LOC(CMON) THEN
BEGIN ! Added by ARG;
WLDASG(CMON:CONCLUSION[SS],XXXWLD(IW,TRUE),OW,NF);
OW←XXXWLD(IW);
END
ELSE
OW←XXXWLD(IW);
STMNT:OW[S]←OW;
XIT: END;
! check_guards;
PROCEDURE CHECK_GUARDS(ITEMVAR IW,OW);
BEGIN
RPTR(FACT) F;
INTEGER OWX;
ITEMVAR GW,WW;
OWX←WLDINX(OW);
∀ WW | ALERT_ORDER⊗IW≡WW DO
BEGIN
GW←GUARD[WLDINX(WW)];
IF GW=ANY THEN CONTINUE;
∀ | GEN_FACTS(F,GW) DO
BEGIN
IF ¬TSTWIX(F,OWX) THEN
BEGIN
INTEGER CTL;
CTL←GETPRINT;
SETPRINT(NULL,"C");
PRINT(CRLF&"WARNING: ");
RECPRN(FACT:PATT[F]);
PRINT(" WAS ASSUMED TO BE TRUE, BUT MAY NOT BE"
&CRLF);
IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN
SETPRINT(NULL,"I");
END;
END;
END;
END;
! fluent_check,mergein;
PROCEDURE FLUENT_CHECK(ITEMVAR W;RPTR(FACT) F);
BEGIN
INTEGER WX;
WX←WLDINX(W);
IF TSTWIX(F,WX) ∧ FLUENT_FACT(F) THEN
BEGIN
! FLUENT_REC contains the fluent for F;
CLRWLD(F,WX); ! delete it from world;
IF ¬PMATCH(W,FLUENT:RETRPATT[FLUENT_REC],TRUE) THEN
SETWLD(F,WX); ! this was the only one;
END;
FLUENT_REC←NULL_RECORD; ! sheer paranoia;
END;
PROCEDURE MERGEIN(ITEMVAR IW,OW,IIW);
BEGIN
! OW ← ((OW∪IW) - (IIW-(OW∩IW)))-INCOMPATIBLE_FLUENTS;
RPTR(FACT) F;
INTEGER IWX,OWX,IIWX;
IWX←WLDINX(IW);OWX←WLDINX(OW);IIWX←WLDINX(IIW);
∀ | GEN_FACTS(F,OW) DO
BEGIN
IF ¬TSTWIX(F,IWX)∧TSTWIX(F,IIWX) THEN
CLRWLD(F,OWX);
END;
∀ | GEN_FACTS(F,IW) DO
BEGIN
! RF - Removed extraneous ELSE before the IF;
IF ¬TSTWIX(F,OWX)∧TSTWIX(F,IIWX) THEN
SETWLD(F,OWX);
END;
END;
! cpattl;
LIST PROCEDURE CPATTL(RCELL C;ITEMVAR WLD;REFERENCE RCELL BL);
BEGIN
RANY V;
ITEMVAR IV;
INTEGER VTYP;
LIST PL;
BL←NULL_RECORD;
PL←NIL;
WHILE C≠NULL_RECORD DO
BEGIN "CLOOP"
V←CELL:CAR[C];
VTYP←RECTYPE(V);
IF VTYP=LOC(NOMV) THEN
BEGIN
! fetch nominal value;
V←EVALEXPR(V,WLD);
END
ELSE IF VTYP=LOC(BINDV) THEN
BEGIN
BL←CONS(V,BL);
IV←\(BINDV:RESULT[V])[1];
∂(IV,INTEGER)←∂(IV,INTEGER) LOR BINDB;
! **** BECAUSE OF A SAIL LOSSAGE *****;
PL[∞+1]←IV;
CONTINUE "CLOOP";
END
ELSE IF VTYP≠LOC(VARIABLE) ∧ VTYP≠LOC(SVAL) ∧ VTYP≠LOC(V3ECT)
∧ VTYP≠LOC(TRANS) THEN
USERERR(1,1,"CPATTL DOESN'T EXPECT AN ELEMENT OF TYPE "
&CVRTS(VTYP));
PL←PL&\($ V);
C←CELL:CDR[C];
END;
RETURN(PL);
END;
! asrtit & denyit;
INTERNAL PROCEDURE ASRTIT(RPTR(AFACT,SFACT) F;ITEMVAR IW,OW);
BEGIN
RCELL CC;
IF RECTYPE(F)=LOC(AFACT) THEN
BEGIN
RPTR(EXPRN,VARIABLE) L;
L←AFACT:LEFT[F];
IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
BEGIN
INTEGER CTL;
CTL←GETPRINT;
SETPRINT(NULL,"C");
PRINT(CRLF);
ALPRIN(F);
IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN SETPRINT(NULL,"I");
USERERR(1,1," asrtit given an afact it cannot handle"&crlf);
RETURN;
END
ELSE
VCHANGE(L,EVALEXPR(AFACT:RIGHT[F],IW),OW);
END
ELSE IF RECTYPE(F)=LOC(SFACT) THEN
BEGIN "SASSERT"
LPASRT(OW,CPATTL(SFACT:PATT[F],IW,CC));
IF CC≠NULL_RECORD THEN
USERERR(1,1,"BINDING ASSERTIT??");
END
ELSE
USERERR(1,1,"ASRTIT CALLED WITH FUNNY FACT");
END;
INTERNAL PROCEDURE DENYIT(RPTR(SFACT,AFACT) F;ITEMVAR IW,OW);
BEGIN
RANY CC;
IF RECTYPE(F)=LOC(AFACT) THEN
BEGIN
RPTR(EXPRN,VARIABLE) L;
L←AFACT:LEFT[F];
IF RECTYPE(L)≠LOC(VARIABLE)∨AFACT:RELN[F]≠0 THEN
BEGIN
INTEGER CTL;
CTL←GETPRINT;
SETPRINT(NULL,"C");
PRINT(CRLF);
ALPRIN(F);
IF CTL="F" ∨ CTL="N" ∨ CTL="S" THEN SETPRINT(NULL,"I");
USERERR(1,1," denyit given an afact it cannot handle"&crlf);
RETURN;
END
ELSE
BEGIN
IF EXPEQV(EVALEXPR(L,IW),EVALEXPR(AFACT:RIGHT[F],IW)) THEN
INVALIDATE(L,OW);
END;
END
ELSE IF RECTYPE(F)=LOC(SFACT) THEN
BEGIN "SDENY"
LPDENY(OW,CPATTL(SFACT:PATT[F],IW,CC));
IF CC≠NULL_RECORD THEN
USERERR(1,1," binding denyit?? ");
END
ELSE
USERERR(1,1,"DENYIT CALLED WITH FUNNY FACT");
END;
! new_exprn, stmake, new_stmnt, new_gassign, new_alsodo;
INTERNAL RPTR(EXPRN) PROCEDURE NEW_EXPRN(INTEGER DT,OP;RCELL ARGS);
BEGIN
RPTR(EXPRN) E;
E←NEW_RECORD(EXPRN);
EXPRN:DATATYPE[E]←DT;
EXPRN:OP[E]←OP;
EXPRN:ARGS[E]←ARGS;
RETURN(E);
END;
INTERNAL RPTR(STMNT) PROCEDURE STMAKE(RSSS SEM(NULL_RECORD));
BEGIN
RPTR(STMNT) S;
S←NEW_RECORD(STMNT);
STMNT:SEMANTICS[S]←SEM;
STMNT:ID[S]←NEW(S);
RETURN(S);
END;
INTERNAL RPTR(STMNT) PROCEDURE NEW_STMNT(ITEMVAR IW,OW; RSSS SEM);
BEGIN
RPTR(STMNT) S;
S←STMAKE(SEM);
STMNT:IW[S]←IW;
STMNT:OW[S]←OW;
RETURN(S);
END;
INTERNAL RPTR(GASSIGN) PROCEDURE NEW_GASSIGN(RVAR V;INTEGER OP;
RPTR(CALCULATOR) C);
BEGIN
RPTR(GASSIGN) GA;
GA←NEW_RECORD(GASSIGN);
GASSIGN:VAR[GA]←V;
GASSIGN:OP[GA]←OP;
GASSIGN:CLC[GA]←C;
RETURN(GA);
END;
INTERNAL RPTR(ALSODO) PROCEDURE NEW_ALSODO(RVAR V;INTEGER OP;
RPTR(CHANGER) C);
BEGIN
RPTR(ALSODO) ADO;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←V;
ALSODO:OP[ADO]←OP;
ALSODO:CHG[ADO]←C;
RETURN(ADO);
END;
! younger,afxdget;
RPTR(VARIABLE) PROCEDURE YOUNGER(RPTR(VARIABLE) V1,V2);
BEGIN
RPTR(BLOCK) B1,B2;
B1←VARIABLE:BLK[V1];B2←VARIABLE:BLK[V2];
IF B1=NULL_RECORD THEN RETURN(V2);
IF B2=NULL_RECORD THEN RETURN(V1);
DO BEGIN
IF B1=B2 THEN RETURN(V1);
B1←BLOCK:PARENT[B1];
END UNTIL B1=NULL_RECORD;
B1←VARIABLE:BLK[V1];
DO BEGIN
IF B1=B2 THEN RETURN(V2);
B2←BLOCK:PARENT[B2];
END UNTIL B2=NULL_RECORD;
BUG("CANNOT TELL WHICH IS YOUNGER");
RETURN(V1); ! arbitrary;
END;
RCELL AFXDLIS;
RPTR(AFXDATA) PROCEDURE AFXDGET(RVAR A,B;RPTR(VARIABLE,EXPRN) TT;BOOLEAN MAKENEW);
BEGIN
RCELL C;
RVAR T;
RPTR(AFXDATA) AD;
IF RECTYPE(TT)=LOC(EXPRN) THEN
BEGIN
IF EXPRN:OP[TT]≠TINVRT_OP THEN
BUG("FUNNY EXPRESSION TO AFXGET")
ELSE
T←CHKREC(CELL:CAR[EXPRN:ARGS[TT]],LOC(VARIABLE));
END
ELSE
T←TT;
IF VARIABLE:DATATYPE[T]≠TRANS_DTYPE THEN
BUG("FUNNY BY VARIABLE TO AFXDGET");
C←AFXDLIS;
WHILE C≠NULL_RECORD DO
BEGIN
AD←LLOP(C);
IF AFXDATA:A[AD]=A∧AFXDATA:B[AD]=B∧AFXDATA:T[AD]=T THEN
RETURN(AD);
END;
IF ¬MAKENEW∨TT≠T THEN
BUG("COULDN'T FIND AFX DATA");
AD←NEW_RECORD(AFXDATA);
AFXDATA:A[AD]←A;AFXDATA:B[AD]←B;AFXDATA:T[AD]←T;
AFXDATA:YOUNGEST[AD]←YOUNGER(A,YOUNGER(B,T));
RETURN(CONSON(AD,AFXDLIS));
END;
! controllable, deproach;
BOOLEAN RECPROC CONTROLLABLE(ITEMVAR WLD;RVAR A;
REFERENCE RVAR CF;REFERENCE REXPR BYEXP;
REFERENCE SET SEEN);
BEGIN
RVAR N,RGF;
RPTR(VARIABLE,EXPRN) BYE;
RPTR(EXPRN) E;
IF A=BARM ∨ A=YARM THEN
BEGIN
BYEXP←NULL_RECORD;CF←A;
RETURN(TRUE);
END;
PUT VARIABLE:NAME[A] IN SEEN;
∀ | LPMATCH(WLD,\(AFFIXED,$ A,BIND N,BIND BYE,BIND RGF)) DO
BEGIN
IF VARIABLE:NAME[N] ε SEEN THEN CONTINUE;
IF CONTROLLABLE(WLD,N,CF,E,SEEN) THEN
BEGIN
IF E=NULL_RECORD THEN
BYEXP←BYE
ELSE
BYEXP←NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(E,BYE));
RETURN(TRUE);
END;
END;
RETURN(FALSE);
END;
RECURSIVE BOOLEAN PROCEDURE FIND_DEPROACH(ITEMVAR WLD;RVAR WHAT;
REFERENCE REXPR HOW; SET SEEN);
BEGIN
INTEGER RT;
RVAR N,RGF;
RPTR(VARIABLE,EXPRN) BYE;
REXPR E;
IF LPMATCH(WLD,\(DEPROACH, $ WHAT, BIND HOW)) THEN
BEGIN ! make sure we return a trans;
IF HOW=NILDEPROACH THEN RETURN(TRUE);
IF (RT←RECTYPE(HOW))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[HOW])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[HOW]);
IF RT = LOC(SVAL) THEN
HOW ← NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(HOW,ZHAT));
RETURN(TRUE);
END;
PUT VARIABLE:NAME[WHAT] IN SEEN;
∀ | LPMATCH(WLD,\(AFFIXED, $ WHAT, BIND N, BIND BYE, BIND RGF)) DO
BEGIN
IF VARIABLE:NAME[N] ε SEEN THEN CONTINUE;
IF FIND_DEPROACH(WLD,N,E,SEEN) THEN
BEGIN
IF E = NILDEPROACH THEN HOW ← NILDEPROACH
ELSE
BEGIN
RT ← RECTYPE(E);
IF RT = LOC(VARIABLE) THEN RT ← DTYPE(VARIABLE:DATATYPE[E])
ELSE IF RT = LOC(EXPRN) THEN RT ← EXPRN:DATATYPE[E];
IF RT = LOC(V3ECT) THEN HOW←NEW_EXPRN(V3ECT_DTYPE,RVMUL_OP,
LIST2(NEW_EXPRN(ROTN_DTYPE,ORIENT_OP,CONS(BYE,RNULL)),E))
ELSE HOW←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(
NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NEW_EXPRN(
ROTN_DTYPE,ORIENT_OP,CONS(BYE,RNULL)),NILVECT)),E));
END;
RETURN(TRUE);
END;
END;
RETURN(FALSE);
END;
INTERNAL REXPR PROCEDURE DEPR(RVAR WHAT;ITEMVAR WLD);
BEGIN
REXPR HOW;
SET SEEN;
SEEN ← PHI;
IF FIND_DEPROACH(WLD,WHAT,HOW,SEEN) THEN
BEGIN
INTEGER RT;
IF HOW = NILDEPROACH THEN RETURN(HOW);
RT ← RECTYPE(HOW);
IF RT = LOC(VARIABLE) THEN RT ← DTYPE(VARIABLE:DATATYPE[HOW])
ELSE IF RT = LOC(EXPRN) THEN RT ← EXPRN:DATATYPE[HOW];
IF RT = LOC(V3ECT) THEN RETURN(NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,
LIST2(NILROTN,HOW)))
ELSE RETURN(HOW);
END
ELSE RETURN(NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,NEW_EXPRN(
V3ECT_DTYPE,RVMUL_OP,LIST2(NEW_EXPRN(ROTN_DTYPE,
ORIENT_OP,CONS(WHAT,RNULL)),STAN_DEPROACH)))));
END;
! dexprset, domove, dooperate, dostop;
PROCEDURE DEXPRSET(RPTR(DEXPR) DE;REXPR DX,TX;
INTEGER DATATYPE;
ITEMVAR WLD);
BEGIN
! DX is destination expression from MOVE statement.
TX is correction from affixment structure.
Actual destination should be DX*inv(TX).
Computes planning value in WLD & puts away in
VAL[DE]. Also, puts planning value away into VAR[DE]
via a call to VCHANGE.
;
IF TX≠NULL_RECORD THEN
BEGIN
IF DATATYPE=FRAME_DTYPE THEN
DX ← NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(DX,INVSIMP(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(TX,NULL_RECORD))) ))
ELSE
BUG("DEXPRTYPE CANNOT HANDLE DATATYPE ");
END;
IF RECTYPE(DX)≠LOC(VARIABLE) THEN
IF RECTYPE(DX)≠LOC(EXPRN) THEN
BEGIN
DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←DX;
END
ELSE
BEGIN
IF DEXPR:TMPVAR[DE]≠NULL_RECORD THEN
BEGIN
IF VARIABLE:DATATYPE[DEXPR:TMPVAR[DE]]≠DATATYPE THEN
BUG("WARNING: INCOMPATIBLE TYPES IN USE OF TEMP");
END
ELSE
DEXPR:TMPVAR[DE]←NEW_VAR(NEW(NULL_RECORD),DATATYPE,CURBLK);
DEXPR:VAR[DE]←DEXPR:TMPVAR[DE];
DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←EVALEXPR(DX,WLD);
VCHANGE(DEXPR:VAR[DE],DEXPR:VAL[DE],WLD);
END
ELSE
BEGIN
DEXPR:VAR[DE]←DEXPR:EXPN[DE]←DX;
DEXPR:VAL[DE]←GETVALUE(DX,WLD);
END;
END;
RANY CURRENT_CF;
RECURSIVE PROCEDURE DOMOVE(RPTR(STMNT) S);
BEGIN
RPTR(EXPRN) E;
SET SEEN;
RCELL C;
RANY ONM,X,OLD_CF;
RPTR(MOVE$) MS;
REXPR DEP;
RPTR(ARRIVAL) ARR;
RPTR(FORCE) F;
RPTR(F_FRAME) F_F;
BOOLEAN ARRIVE,DEPART;
INTEGER DT,RT,USE_FORCE,CM_FORCE,I;
ITEMVAR IW,OW;
IW←STMNT:IW[S];OW←STMNT:OW[S];
CPYWLD(IW,OW);
MS ← STMNT:SEMANTICS[S]; ! Added by RF;
SEEN←PHI;
IF MOVE$:WHAT[MS]=YHAND ∨ MOVE$:WHAT[MS]=BHAND THEN
BEGIN ! OK, Ray, you win. But this is a kluge;
E ← NULL_RECORD;
DT←SVAL_DTYPE;
MOVE$:CF[MS] ← MOVE$:WHAT[MS];
END
ELSE
BEGIN
DT←FRAME_DTYPE;
IF ¬CONTROLLABLE(OW,MOVE$:WHAT[MS],MOVE$:CF[MS],E,SEEN) THEN
BUG("MOVE MUST HAVE A CONTROLLABLE FRAME");
END;
OLD_CF ← CURRENT_CF;
CURRENT_CF ← MOVE$:CF[MS];
DEXPRSET(MOVE$:DEXP[MS],MOVE$:DEST[MS],E,DT,OW);
VCHANGE(MOVE$:CF[MS],DEXPR:VAL[MOVE$:DEXP[MS]],OW);
C←MOVE$:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
RPTR(STMNT) SS;
IF RECTYPE(CMON:CONDITION[X]) = LOC(FORCE) THEN
CM_FORCE ← CM_FORCE + 1;
IF MOVE$:CF[MS] = YARM THEN
CMON:FLAGS[X] ← CMON:FLAGS[X] + 2; ! Remember which arm;
SS←STMCHK(CMON:CONCLUSION[X]);
CPYWLD(IW,STMNT:IW[SS]);
STINTERP(SS);
! used to do an ANDWLD(STMNT:OW[X],OW,OW) here;
END
ELSE IF RT=LOCATION(FORCE) THEN
BEGIN
USE_FORCE ← USE_FORCE + 1;
END
ELSE IF RT=LOCATION(F_FRAME) THEN
BEGIN
F_F ← X; ! Remember force frame;
END
ELSE IF RT=LOCATION(S_FAC) THEN
BEGIN
S_FAC:VAL[X] ← EVALEXPR(S_FAC:VAL[X],IW);
END
ELSE IF RT=LOCATION(WOBBLE) THEN
BEGIN
WOBBLE:VAL[X] ← EVALEXPR(WOBBLE:VAL[X],IW);
END
ELSE IF RT=LOCATION(VIA) THEN
BEGIN
DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
END
ELSE IF RT=LOCATION(ARRIVAL) THEN
BEGIN
ARRIVE ← TRUE;
DEP ← ARRIVAL:THRU[X];
IF DEP≠NILDEPROACH THEN
BEGIN
ARR ← X;
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
DEP));
DEXPRSET(ARRIVAL:ACTPLACE[X],NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:DEST[MS],DEP)),E,DT,OW);
END;
END
ELSE IF RT=LOCATION(DEPARTURE) THEN
BEGIN
DEPART ← TRUE;
DEP ← DEPARTURE:THRU[X];
IF DEP≠NILDEPROACH THEN
BEGIN
IF (RT←RECTYPE(DEP))=LOC(VARIABLE) THEN
RT ← DTYPE(VARIABLE:DATATYPE[DEP])
ELSE IF RT=LOC(EXPRN) THEN RT←DTYPE(EXPRN:DATATYPE[DEP]);
IF RT = LOC(SVAL) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
NEW_EXPRN(V3ECT_DTYPE,SVMUL_OP,LIST2(DEP,ZHAT))))
ELSE IF RT = LOC(V3ECT) THEN
DEP ← NEW_EXPRN(TRANS_DTYPE,TMAKE_OP,LIST2(NILROTN,
DEP));
DEP ← IF E = NULL_RECORD THEN
NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(GETVALUE(MOVE$:CF[MS],IW),DEP))
ELSE NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,LIST2(
NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(GETVALUE(MOVE$:CF[MS],IW),E)),DEP));
DEXPRSET(DEPARTURE:ACTPLACE[X],DEP,E,DT,OW);
END;
END
END;
IF ¬ARRIVE ∧ DT=FRAME_DTYPE ∧ RECTYPE(MOVE$:DEST[MS])=LOC(VARIABLE) THEN
BEGIN ! add arrival;
DEP ← DEPR(MOVE$:DEST[MS],IW);
IF DEP ≠ NILDEPROACH THEN
BEGIN
ARR ← NEW_RECORD(ARRIVAL);
CONSON(ARR,MOVE$:CLAUSES[MS]);
ARRIVAL:ACTPLACE[ARR] ← NEW_RECORD(DEXPR);
DEXPRSET(ARRIVAL:ACTPLACE[ARR],NEW_EXPRN(TRANS_DTYPE,
TTMUL_OP,LIST2(MOVE$:DEST[MS],DEP)),E,DT,OW);
END;
END;
IF ¬DEPART ∧ ( (MOVE$:CF[MS]=BARM ∧ GETVALUE(BDEPROACH,IW)≠NILDEPROACH) ∨
(MOVE$:CF[MS]=YARM ∧ GETVALUE(YDEPROACH,IW)≠NILDEPROACH) ) THEN
BEGIN ! add departure;
RPTR(DEPARTURE) DPR;
DPR ← NEW_RECORD(DEPARTURE);
CONSON(DPR,MOVE$:CLAUSES[MS]);
DEPARTURE:ACTPLACE[DPR] ← NEW_RECORD(DEXPR);
DEP ← IF MOVE$:CF[MS]=BARM THEN BDEPROACH ELSE YDEPROACH;
DEXPRSET(DEPARTURE:ACTPLACE[DPR],DEP,RNULL,DT,OW);
END;
IF DT=FRAME_DTYPE THEN
IF ARR=RNULL THEN
IF MOVE$:CF[MS]=BARM THEN VCHANGE(BDEPROACH,NILDEPROACH,OW)
ELSE VCHANGE(BDEPROACH,NILDEPROACH,OW)
ELSE IF MOVE$:CF[MS]=BARM THEN
VCHANGE(BDEPROACH,DEXPR:VAL[ARRIVAL:ACTPLACE[ARR]],OW)
ELSE VCHANGE(YDEPROACH,DEXPR:VAL[ARRIVAL:ACTPLACE[ARR]],OW);
IF ¬ USE_FORCE ∧ CM_FORCE = 1 THEN
BEGIN "only sense"
C ← MOVE$:CLAUSES[MS];
DO X ← LLOP(C) UNTIL RECTYPE(X)=LOC(CMON) ∧
RECTYPE(CMON:CONDITION[X])=LOC(FORCE);
F ← CMON:CONDITION[X];
IF FORCE:F_F[F] = RNULL ∧ F_F = RNULL ∧ (FORCE:DIRECT[F] = XHAT ∨
FORCE:DIRECT[F] = YHAT ∨ FORCE:DIRECT[F] =ZHAT) THEN
BEGIN ! Need to specify a force frame;
FORCE:F_F[F] ← F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Use table coordinates;
END;
IF (F_F ← FORCE:F_F[F]) ≠ RNULL THEN F_FRAME:C_SYS[F_F] ←
F_FRAME:C_SYS[F_F] lor
MEMLOC(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM,INTEGER);
END "only sense"
ELSE IF USE_FORCE ∨ CM_FORCE THEN
BEGIN "multiple sense/apply"
I ← USE_FORCE + CM_FORCE;
C ← MOVE$:CLAUSES[MS];
WHILE I DO
BEGIN "find the force clauses"
X ← LLOP(C);
IF (RT←RECTYPE(X))=LOC(CMON) ∧ RECTYPE(CMON:CONDITION[X])=LOC(FORCE)
THEN F ← CMON:CONDITION[X]
ELSE IF RT=LOC(FORCE) THEN F ← X ELSE CONTINUE;
I ← I - 1;
IF FORCE:DIRECT[F]≠XHAT ∧FORCE:DIRECT[F]≠YHAT ∧FORCE:DIRECT[F]≠ZHAT THEN
IF USE_FORCE + CM_FORCE = 1 THEN
BEGIN "single apply"
IF F_F ≠ RNULL THEN
BEGIN ! Multiply defined force frames;
ALPRIN(MS);
BUG("MOVE statement has multiply defined force frames");
END;
FORCE:F_F[F] ← NEW_RECORD(F_FRAME);
F_FRAME:C_SYS[FORCE:F_F[F]] ← FTABLE +
(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM);
DONE;
END "single apply"
ELSE BEGIN "axis error"
ALPRIN(MS);
BUG("Force direction must be along an axis - Assuming ZHAT");
FORCE:DIRECT[F] ← ZHAT;
END "axis error";
IF F_F = RNULL THEN F_F ← FORCE:F_F[F] ! Make the first force frame we;
! see the default, unless the MOVE specified one;
ELSE IF FORCE:F_F[F] ≠ RNULL ∧
(F_FRAME:FRAME[F_F]≠F_FRAME:FRAME[FORCE:F_F[F]] ∨
F_FRAME:C_SYS[F_F]≠F_FRAME:C_SYS[FORCE:F_F[F]]) THEN
BEGIN ! Multiply defined force frames;
ALPRIN(MS);
BUG("MOVE statement has multiply defined force frames");
END;
IF RT=LOC(CMON) THEN FORCE:F_F[F] ← RNULL; ! null out the field so;
! cmon's will be coded right - (a kluge?);
END "find the force clauses";
IF F_F = RNULL ∧ USE_FORCE+CM_FORCE>1 THEN
BEGIN ! no force frame specified;
ALPRIN(MS);
BUG("No force frame specified in MOVE statement - Assuming station");
F_F ← NEW_RECORD(F_FRAME);
F_FRAME:FRAME[F_F] ← STATION; ! Use standard orientation;
F_FRAME:C_SYS[F_F] ← FTABLE; ! Use table coordinates;
END;
IF F_F ≠ RNULL THEN
BEGIN
F_FRAME:C_SYS[F_F] ← F_FRAME:C_SYS[F_F] lor
MEMLOC(IF MOVE$:CF[MS]=YARM THEN YELARM ELSE BLUARM,INTEGER);
CONSON(F_F,MOVE$:CLAUSES[MS]); ! May already be somewhere in clause list;
END; ! but...;
END "multiple sense/apply";
CURRENT_CF ← OLD_CF;
END;
RECURSIVE PROCEDURE DOOPERATE(RPTR(STMNT) S);
BEGIN ! Modified by RF from DOMOVE;
RPTR(EXPRN) E;
SET SEEN;
RCELL C;
RANY ONM;
RPTR(OPERATE) MS;
INTEGER DT;
ITEMVAR IW,OW;
IW←STMNT:IW[S];OW←STMNT:OW[S];
CPYWLD(IW,OW);
MS ← STMNT:SEMANTICS[S]; ! Added by RF;
SEEN←PHI;
IF OPERATE:WHAT[MS]=YHAND ∨ OPERATE:WHAT[MS]=BHAND THEN
BEGIN ! OK, Ray, you win. But this is a kluge;
E ← NULL_RECORD;
DT←SVAL_DTYPE;
OPERATE:CF[MS] ← OPERATE:WHAT[MS];
END
ELSE BUG("OPERATE MUST USE A HAND");
DEXPRSET(OPERATE:DEXP[MS],OPERATE:DEST[MS],E,DT,OW);
VCHANGE(OPERATE:CF[MS],DEXPR:VAL[OPERATE:DEXP[MS]],OW);
C←OPERATE:CLAUSES[MS];
WHILE C≠NULL_RECORD DO
BEGIN
RANY X;INTEGER RT;
X←LLOP(C);
IF (RT←RECTYPE(X))=LOCATION(CMON) THEN
BEGIN
STINTERP(STMCHK(CMON:CONCLUSION[X]));
ANDWLD(STMNT:OW[X],OW,OW);
END
ELSE IF RT=LOCATION(VIA) THEN
BEGIN
DEXPRSET(VIA:ACTPLACE[X],VIA:PLACE[X],E,DT,OW);
END;
END;
END;
RECURSIVE PROCEDURE DOSTOP(RPTR(STMNT) S);
BEGIN ! Added by ARG;
RPTR(EXPRN) E;
SET SEEN;
RPTR(STOP) MS;
ITEMVAR OW;
OW←STMNT:OW[S];
MS ← STMNT:SEMANTICS[S];
SEEN←PHI;
IF STOP:CF[MS] = RNULL ∧ CURRENT_CF ≠ RNULL THEN STOP:CF[MS] ← CURRENT_CF
ELSE IF ¬CONTROLLABLE(OW,STOP:CF[MS],STOP:CF[MS],E,SEEN) THEN
BEGIN
BUG("STOP MUST HAVE A CONTROLLABLE FRAME - ASSUMING BARM");
STOP:CF[MS]←BARM;
END;
END;
! do_affix, do_affix_stmnt, do_unfix;
INTERNAL PROCEDURE DO_UNFIX(ITEMVAR OW;RVAR F1,F2;REFERENCE RCELL GPHCODE);
BEGIN
RPTR(EXPRN,VARIABLE) BYEX;
RPTR(AFXDATA) AD;
RVAR RGF;
IF LPMATCH(OW,\(AFFIXED,$ F1,$ F2,BIND BYEX,BIND RGF) ) THEN
BEGIN
DENYF(OW,_FACT_);
AD←AFXDGET(F1,F2,BYEX,FALSE);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:T[AD]=BYEX THEN
BYEX←AFXDATA:INVT[AD]
ELSE
BYEX←AFXDATA:T[AD];
LPDENY(OW,\(AFFIXED,$ F2,$ F1,BYEX,RIGIDLY) );
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCALC(OW,F2,AFXDATA:C2[AD]);
CONSON(NEW_GASSIGN(F2,2,AFXDATA:C2[AD]),GPHCODE);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
REMCALC(OW,F1,AFXDATA:C1[AD]);
REMCHG(OW,F1,AFXDATA:CHG[AD]);
! should kill old one!; CONSON(NEW_ALSODO(F1,2,AFXDATA:CHG[AD]),GPHCODE);
END;
CONSON(NEW_GASSIGN(F1,2,AFXDATA:C1[AD]),GPHCODE);
END;
END;
INTERNAL PROCEDURE DO_AFFIX(ITEMVAR OW;RVAR F1,F2,BV;REXPR AE;RVAR RGF;
REFERENCE RCELL GPHCODE);
BEGIN
RANY ASTN;
RPTR(TRANS) T;
RPTR(AFXDATA) AD;
RPTR(VARIABLE) BVV;
RPTR(BLOCK) BID;
RPTR(ASSIGNMENT) ASG;
DO_UNFIX(OW,F1,F2,GPHCODE);
AD←AFXDGET(F1,F2,BV,TRUE);
IF AE=NULL_RECORD THEN
AE←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,CONS(F2,NULL_RECORD)),F1));
! FTOF(F2,F1);
VCHANGE(BV,EVALEXPR(AE,OW),OW);
BID←VARIABLE:BLK[AFXDATA:YOUNGEST[AD]];
LPASRT(OW,\(AFFIXED,$ F1, $ F2, $ BV, $ RGF));
IF AFXDATA:C1[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:C1[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F2,BV) ),BID));
END;
CONSON(NEW_GASSIGN(F1,1,AFXDATA:C1[AD]),GPHCODE);
ADDCALC(OW,F1,AFXDATA:C1[AD]);
IF RGF=RIGIDLY THEN
BEGIN
IF AFXDATA:INVT[AD]=NULL_RECORD THEN
BEGIN
AFXDATA:INVT[AD]←NEW_EXPRN(TRANS_DTYPE,
TINVRT_OP,CONS(BV,NULL_RECORD));
AFXDATA:C2[AD]←ASGLBL(NEW_LBL(ANY,CLCLAB_DTYPE,BID),
BLDCALC(OW,NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(F1,AFXDATA:INVT[AD])),BID));
END;
CONSON(NEW_GASSIGN(F2,1,AFXDATA:C2[AD]),GPHCODE);
LPASRT(OW,\(AFFIXED,$ F2,$ F1,$ AFXDATA:INVT[AD], RIGIDLY));
ADDCALC(OW,F2,AFXDATA:C2[AD]);
END
ELSE
BEGIN
RPTR(ALSODO) ADO;
IF AFXDATA:CHG[AD]=NULL_RECORD THEN
BEGIN
RVAR FF2; ! to get around a SAIL lossage;
RPTR(ASSIGNMENT) ASG;
FF2←F2;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←NEW_EXPRN(TRANS_DTYPE,TTMUL_OP,
LIST2(NEW_EXPRN(TRANS_DTYPE,TINVRT_OP,
CONS(FF2,NULL_RECORD)),
VNEWTRANS) );
AFXDATA:CHG[AD]←ASGLBL(NEW_LBL(ANY,CHGLAB_DTYPE,BID),
BLDCHG(STMAKE(ASG),BID));
END;
ADO←NEW_RECORD(ALSODO);
ALSODO:VAR[ADO]←F1;ALSODO:OP[ADO]←1;
ALSODO:CHG[ADO]←AFXDATA:CHG[AD];
ADDCHG(OW,F1,AFXDATA:CHG[AD]);
CONSON(ADO,GPHCODE);
END;
ASG←NEW_RECORD(ASSIGNMENT);
ASSIGNMENT:VAR[ASG]←BV;
ASSIGNMENT:VAL[ASG]←AE;
CONSON(ASG,GPHCODE);
END;
! blockdo & sttblk, blkopdo;
RECPROC BLOCKDO(RPTR(STMNT) S);
BEGIN
ITEMVAR IW;
RCELL C;
RPTR(BLOCK) OCB;
SIMPLE PROCEDURE OCBDO;CURBLK←OCB;
CLEANUP OCBDO;
OCB←CURBLK;
CURBLK←STMNT:SEMANTICS[S];
C←BLOCK:CODE[CURBLK];
IW←STMNT:IW[S];
WHILE C≠NULL_RECORD DO
BEGIN
INTEGER ST;
ST←RECTYPE(CELL:CAR[C]);
IF ST=LOC(STMNT) THEN
BEGIN
STINTERP(CELL:CAR[C]);
IW←STMNT:OW[CELL:CAR[C]];
END
ELSE IF ST=LOC(PVL) THEN
PVLDO(PVL:VL[CELL:CAR[C]],IW)
ELSE IF ST=LOC(VARIABLE) THEN
BEGIN
END
ELSE IF ST=LOC(DBD) THEN
WLDDMP(DBD:WLD[CELL:CAR[C]])
ELSE IF ST=LOC(NW) THEN
BEGIN
END
ELSE IF ST=LOC(NOTE) THEN
PRINT(∂(STCONST:VAL[NOTE:HESAYS[CELL:CAR[C]]]),CRLF)
ELSE IF ST=LOC(NOTE1) THEN
PRINT(∂(STCONST:VAL[NOTE1:HESAYS[CELL:CAR[C]]]),CRLF)
ELSE IF ST=LOC(NOTE2) THEN
BEGIN
END
ELSE
BEGIN
USERERR(1,1,"FUNNY BLOCK ELEMENT");
END;
C←CELL:CDR[C];
END;
END;
INTERNAL RANY PROCEDURE STTBLK(RANY S); ! Used to be rptr(block) procedure;
BEGIN
RPTR(BLOCK) B;
IF RECTYPE(S)≠LOC(BLOCK) THEN
BEGIN
B←NEW_RECORD(BLOCK);
BLOCK:CODE[B]←CONS(S,NULL_RECORD);
RETURN(STMAKE(B));
END;
RETURN(S);
END;
PROCEDURE BLKOPDO(ITEMVAR W;INTEGER OP);
BEGIN
RCELL C;
CASE OP OF
BEGIN
[ENTERBLOCK] BEGIN
C←BLOCK:CLCS[CURBLK];
WHILE C≠NULL_RECORD DO
MK_CALC(W,LLOP(C));
END;
[LEAVEBLOCK] BEGIN
C←BLOCK:CLCS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLCALC(W,LLOP(C));
C←BLOCK:ALSOS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLCHG(W,LLOP(C));
C←BLOCK:VARS[CURBLK];
WHILE C≠NULL_RECORD DO
KILLVAR(W,LLOP(C));
END;
[0] END;
END;
! Cobdo;
RECPROC COBDO(RPTR(STMNT) S);
BEGIN
RCELL C;
BOOLEAN FLAG;
RPTR(STMNT) SS;
RPTR(FACT) F;
C←COBLOCK:CODE[CHKREC(STMNT:SEMANTICS[S],LOC(COBLOCK))];
FLAG←FALSE;
WHILE C≠NULL_RECORD DO
BEGIN
SS←STMCHK(CELL:CAR[C]);
CPYWLD(STMNT:IW[S],STMNT:IW[SS]);
STINTERP(SS);
IF FLAG THEN
! RF - added third argument to this call;
MERGEIN(STMNT:OW[SS],STMNT:OW[S],STMNT:OW[SS])
ELSE
BEGIN
FLAG←TRUE;
CPYWLD(STMNT:OW[SS],STMNT:OW[S]);
END;
C←CELL:CDR[C];
END;
IF ¬FLAG THEN
CPYWLD(STMNT:IW[S],STMNT:OW[S]);
∀ | GEN_FACTS(F,STMNT:OW[S]) DO
FLUENT_CHECK(STMNT:OW[S],F);
END;
! loopbdo;
RECPROC LOOPBDO(RPTR(STMNT) S);
BEGIN
CALL_ALERT(STMNT:IW[S]);
STINTERP(S);
CHECK_GUARDS(STMNT:IW[S],STMNT:OW[S]);
END;
! statement interpreter: stinterp (owdo, iwcopy);
INTERNAL RECPROC STINTERP(RPTR(STMNT) S);
BEGIN
! Takes the statement S and interprets what it would do to
the world. The worlds associated with S are actually
modified;
INTEGER STYP;
ITEMVAR IW,OW;
RSSS SS;
RPTR(STMNT) S1,S2;
LABEL XIT,YETMORE;
PROCEDURE OWDO;
CPYWLD(IW,OW);
SIMPLE PROCEDURE IWCOPY(RPTR(STMNT) SX);
CPYWLD(IW,STMNT:IW[SX]);
IF S=NULL_RECORD THEN
RETURN;
IF RECTYPE(S) ≠ LOC(STMNT)
THEN BEGIN ! Added by RF;
USERERR(1,1,"STINTERP: Not a statement");
RETURN;
END;
! IF ¬UNBOUND(STMNT:PRC[S]) THEN
! BEGIN
! DEFINE PREDICT_EFFECTS_REC "[]" = "RPEFCT";
! EXTERNAL RANY PREDICT_EFFECTS_REC;
! ! defined in RHTREC;
! REC_RESUME(STMNT:PRC[S],PREDICT_EFFECTS_REC);
! RETURN;
! END;
SS←STMNT:SEMANTICS[S];
STYP←RECTYPE(SS);
IF STITRC LAND '1 THEN
PRINT(CRLF&"STATEMENT TYPE =",CVOS(STYP));
IF STITRC LAND '2 THEN
BEGIN
PRINT(CRLF&"STATEMENT RECORD =");
ALPRIN(S);
END;
IW←STMNT:IW[S];
OW←STMNT:OW[S];
IF SS=NULL_RECORD THEN
BEGIN
OWDO; ! null semantics changes nothing;
RETURN;
END;
IF STYP=LOC(BLOCK) THEN
BLOCKDO(S)
ELSE IF STYP=LOC(ASSIGNMENT) THEN
BEGIN
OWDO;
VCHANGE(ASSIGNMENT:VAR[SS],
EVALEXPR(ASSIGNMENT:VAL[SS],OW),OW);
! note that this is OW now (so side effects happen);
END
ELSE IF STYP=LOC(GASSIGN) THEN
BEGIN
OWDO;
INVALIDATE(GASSIGN:VAR[SS],OW);
CASE GASSIGN:OP[SS] OF
BEGIN
[1] ADDCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
[2] REMCALC(OW,GASSIGN:VAR[SS],GASSIGN:CLC[SS]);
[3] USERERR(1,1,"ONLY CALC TEMPROARILY MISSING");
[0] USERERR(1,1,"ILLEGAL GRAPH ASSIGNMENT OP")
END;
END
ELSE IF STYP=LOC(IFF) THEN
BEGIN
! here need code to handle conditional;
S1←STMCHK(IFF:THN[SS]);
S2←STMCHK(IFF:ELS[SS]);
IWCOPY(S1);
IWCOPY(S2);
STINTERP(S1);
STINTERP(S2);
ANDWLD(STMNT:OW[S1],STMNT:OW[S2],OW);
END
ELSE IF STYP=LOC(COBLOCK) THEN
BEGIN
COBDO(S);
END
ELSE IF STYP=LOC(WHIL) THEN
BEGIN
S1←WHIL:BODY[SS];
IF S1≠NULL_RECORD THEN
BEGIN
S1←STMCHK(S1);
IWCOPY(S1);
LOOPBDO(S1);
! used to do an ANDWLD(STMNT:OW[S1],IW,OW) here, but
I'm more liberal than RHT - ARG 10/76;
END
ELSE
OWDO;
END
ELSE IF STYP=LOC(FORR) THEN
BEGIN ! Added by RF;
S1←FORR:BODY[SS];
IF S1≠NULL_RECORD THEN
BEGIN
S1←STMCHK(S1);
IWCOPY(S1);
LOOPBDO(S1);
! used to do an ANDWLD(STMNT:OW[S1],IW,OW) here, but
I'm more liberal than RHT - ARG 10/76;
END
ELSE
OWDO;
END
ELSE IF STYP=LOC(ASSERT) THEN
BEGIN
OWDO;
ASRTIT(ASSERT:FACT[SS],IW,ASSERT:WLD[SS]);
END
ELSE IF STYP=LOC(DENY) THEN
BEGIN
OWDO;
DENYIT(DENY:FACT[SS],IW,DENY:WLD[SS]);
END
ELSE IF STYP=LOC(AFFIX) THEN
BEGIN
OWDO;
AFFIX:GPHCODE[SS]←NULL_RECORD;
DO_AFFIX(OW,AFFIX:FRAME1[SS],AFFIX:FRAME2[SS],AFFIX:BYVAR[SS],
AFFIX:ATEXP[SS],AFFIX:RIGID[SS],AFFIX:GPHCODE[SS]);
END
ELSE IF STYP=LOC(UNFIX) THEN
BEGIN
OWDO;UNFIX:GPHCODE[SS]←NULL_RECORD;
DO_UNFIX(OW,UNFIX:FRAME1[SS],UNFIX:FRAME2[SS],UNFIX:GPHCODE[SS]);
END
ELSE IF STYP=LOC(BLKOP) THEN
BEGIN
OWDO;
BLKOPDO(OW,BLKOP:OP[SS]);
END
ELSE IF STYP=LOC(NW) THEN
OWDO
ELSE IF STYP = LOC(MOVE$) THEN
BEGIN "move"
DOMOVE(S);
END "move"
ELSE IF STYP = LOC(OPERATE) THEN
BEGIN "operate"
DOOPERATE(S);
END "operate"
ELSE IF STYP = LOC(STOP) THEN
BEGIN "stop"
OWDO;
DOSTOP(S); ! Added by ARG;
END "stop"
ELSE
GO TO YETMORE; ! to get around SAILs parse stack limits
without using /R ;
GO TO XIT;
YETMORE:IF STYP = LOC(COMMNT) ∨ STYP = LOC(CENTER) ∨ STYP = LOC(CMABLE)
∨ STYP = LOC(PRNT) ∨ STYP = LOC(PAUSE) ∨ STYP = LOC(ABORT) THEN
BEGIN "others" ! Added by RF, added to by ARG;
OWDO;
END "others"
ELSE IF STYP = LOC(ALSODO) THEN
BEGIN "alsodo" ! Added by RF;
OWDO;
ADDCHG(OW,ALSODO:VAR[SS],ALSODO:CHG[SS]);
END "alsodo"
ELSE IF STYP = LOC(CMON) THEN
BEGIN "cmon" ! Added by RF;
S1 ← STMCHK(CMON:CONCLUSION[SS]);
IWCOPY(S1);
STINTERP(S1);
OWDO; ! Ignore any effects the CMON may have;
END "cmon"
ELSE IF STYP = LOC(EVDO) THEN
BEGIN "evdo" ! Added by RF;
OWDO; ! Temporarily does nothing;
END "evdo"
ELSE IF STYP = LOC(S_FAC) THEN
BEGIN "s_fac" ! Added by arg;
OWDO;
VCHANGE(SPEED_FACTR,EVALEXPR(S_FAC:VAL[SS],IW),OW);
END "s_fac"
ELSE IF STYP = LOC(PROG) THEN ! added by RF;
BEGIN
VCHANGE(BARM,BPARK,IW); ! Initialize arm positions;
VCHANGE(YARM,YPARK,IW);
VCHANGE(SPEED_FACTR,TRUEV,IW); ! Set speed_factor to 1;
VARIABLE:VAL[BHAND]←VARIABLE:VAL[YHAND]←NEW_SVAL(2);
VCHANGE(BDEPROACH,NILDEPROACH,IW); ! more initialization;
VCHANGE(YDEPROACH,NILDEPROACH,IW);
STINTERP(PROG:CODE[SS]);
IF GETVALUE(BARM,OW)≠BPARK THEN
USERERR(0,1,"WARNING: BLUE ARM NOT PARKED UPON PROGRAM "&
"COMPLETION.","C");
IF GETVALUE(YARM,OW)≠YPARK THEN
USERERR(0,1,"WARNING: YELLOW ARM NOT PARKED UPON PROGRAM "&
"COMPLETION.","C");
END
ELSE
BEGIN
PRINT(CRLF&"***");
ALPRIN(SS);
USERERR(1,1," STINTERP GIVEN A STATEMENT TYPE IT CANNOT HANDLE");
END;
XIT: END;
ifcr false thenc ! proc_form interpreter: apfrm, apfrm2;
INTERNAL RECPROC APFRM(RPTR(PROC_FORM) PF;RCELL VL);
BEGIN
RCELL PFFPL;
PFFPL←PROC_FORM:FPS[PF];
WHILE PFFPL≠NULL_RECORD ∧ VL≠NULL_RECORD DO
BEGIN
VCELL:VAL[CELL:CAR[PFFPL]]←CELL:CAR[VL];
PFFPL←CELL:CDR[PFFPL];
VL←CELL:CDR[VL];
END;
STINTERP(PROC_FORM:S[PF]);
END;
INTERNAL RECPROC APFRM2(RPTR(PROC_FORM) PF;RPTR(VALU$) V1,V2);
BEGIN
RCELL PFFPL;
RPTR(VALU$) V;
PFFPL←PROC_FORM:FPS[PF];
FOR V←V1,V2 DO
BEGIN
IF PFFPL=NULL_RECORD THEN DONE;
VCELL:VAL[CELL:CAR[PFFPL]]←V;
PFFPL←CELL:CDR[PFFPL];
END;
STINTERP(PROC_FORM:S[PF]);
END;
endc
! test program;
IFCR FALSE THENC
INTERNAL PROCEDURE WMTEST;
WHILE TRUE DO
BEGIN
REQUIRE "GOBBLE.HDR[AL,HE]" SOURCE_FILE;
INTEGER NF,F,D;
RCELL SE;
RANY ST;
RPTR(STMNT) BS;
GETFORMAT(F,D);
SETFORMAT(0,3);
SE←READ;
ST←GROVEL(SE);
BS←STTBLK(ST);
NF←TRUE;
WLDASG(BS,CURWLD,CURWLD,NF);
ALPRIN(BS);
PRINT(CRLF);
STINTERP(BS);
SETFORMAT(F,D);
END;
ENDC
END $$PRGID;